home *** CD-ROM | disk | FTP | other *** search
/ Chip 2002 June / Chip_2002-06_cd1.bin / zkuste / delphi / kolekce / d6 / rxlibsetup.exe / {app} / units / RXSpin.pas < prev    next >
Encoding:
Pascal/Delphi Source File  |  2002-02-19  |  30.6 KB  |  1,137 lines
  1. {*******************************************************}
  2. {                                                       }
  3. {         Delphi VCL Extensions (RX)                    }
  4. {                                                       }
  5. {         Copyright (c) 2001,2002 SGB Software          }
  6. {         Copyright (c) 1997, 1998 Fedor Koshevnikov,   }
  7. {                        Igor Pavluk and Serge Korolev  }
  8. {                                                       }
  9. {*******************************************************}
  10.  
  11. unit RXSpin;
  12.  
  13. interface
  14.  
  15. {$I RX.INC}
  16.  
  17. uses {$IFDEF WIN32} Windows, ComCtrls, {$ELSE} WinTypes, WinProcs, {$ENDIF}
  18.   Controls, ExtCtrls, Classes, Graphics, Messages, Forms, StdCtrls, Menus,
  19.   SysUtils;
  20.  
  21. type
  22.  
  23. { TRxSpinButton }
  24.  
  25.   TSpinButtonState = (sbNotDown, sbTopDown, sbBottomDown);
  26.  
  27.   TRxSpinButton = class(TGraphicControl)
  28.   private
  29.     FDown: TSpinButtonState;
  30.     FUpBitmap: TBitmap;
  31.     FDownBitmap: TBitmap;
  32.     FDragging: Boolean;
  33.     FInvalidate: Boolean;
  34.     FTopDownBtn: TBitmap;
  35.     FBottomDownBtn: TBitmap;
  36.     FRepeatTimer: TTimer;
  37.     FNotDownBtn: TBitmap;
  38.     FLastDown: TSpinButtonState;
  39.     FFocusControl: TWinControl;
  40.     FOnTopClick: TNotifyEvent;
  41.     FOnBottomClick: TNotifyEvent;
  42.     procedure TopClick;
  43.     procedure BottomClick;
  44.     procedure GlyphChanged(Sender: TObject);
  45.     function GetUpGlyph: TBitmap;
  46.     function GetDownGlyph: TBitmap;
  47.     procedure SetUpGlyph(Value: TBitmap);
  48.     procedure SetDownGlyph(Value: TBitmap);
  49.     procedure SetDown(Value: TSpinButtonState);
  50.     procedure SetFocusControl(Value: TWinControl);
  51.     procedure DrawAllBitmap;
  52.     procedure DrawBitmap(ABitmap: TBitmap; ADownState: TSpinButtonState);
  53.     procedure TimerExpired(Sender: TObject);
  54.     procedure CMEnabledChanged(var Message: TMessage); message CM_ENABLEDCHANGED;
  55.   protected
  56.     procedure Paint; override;
  57.     procedure MouseDown(Button: TMouseButton; Shift: TShiftState;
  58.       X, Y: Integer); override;
  59.     procedure MouseMove(Shift: TShiftState; X, Y: Integer); override;
  60.     procedure MouseUp(Button: TMouseButton; Shift: TShiftState;
  61.       X, Y: Integer); override;
  62.     procedure Notification(AComponent: TComponent;
  63.       Operation: TOperation); override;
  64.   public
  65.     constructor Create(AOwner: TComponent); override;
  66.     destructor Destroy; override;
  67.     property Down: TSpinButtonState read FDown write SetDown default sbNotDown;
  68.   published
  69.     property DragCursor;
  70.     property DragMode;
  71.     property Enabled;
  72.     property Visible;
  73.     property DownGlyph: TBitmap read GetDownGlyph write SetDownGlyph;
  74.     property UpGlyph: TBitmap read GetUpGlyph write SetUpGlyph;
  75.     property FocusControl: TWinControl read FFocusControl write SetFocusControl;
  76.     property ShowHint;
  77.     property ParentShowHint;
  78. {$IFDEF RX_D4}
  79.     property Anchors;
  80.     property Constraints;
  81.     property DragKind;
  82. {$ENDIF}
  83.     property OnBottomClick: TNotifyEvent read FOnBottomClick write FOnBottomClick;
  84.     property OnTopClick: TNotifyEvent read FOnTopClick write FOnTopClick;
  85.     property OnDragDrop;
  86.     property OnDragOver;
  87.     property OnEndDrag;
  88. {$IFDEF WIN32}
  89.     property OnStartDrag;
  90. {$ENDIF}
  91. {$IFDEF RX_D4}
  92.     property OnEndDock;
  93.     property OnStartDock;
  94. {$ENDIF}
  95.   end;
  96.  
  97. { TRxSpinEdit }
  98.  
  99. {$IFDEF CBUILDER}
  100.   TValueType = (vtInt, vtFloat, vtHex);
  101. {$ELSE}
  102.   TValueType = (vtInteger, vtFloat, vtHex);
  103. {$ENDIF}
  104.  
  105. {$IFDEF WIN32}
  106.   TSpinButtonKind = (bkStandard, bkDiagonal);
  107. {$ENDIF}
  108.  
  109.   TRxSpinEdit = class(TCustomEdit)
  110.   private
  111.     FAlignment: TAlignment;
  112.     FMinValue: Extended;
  113.     FMaxValue: Extended;
  114.     FIncrement: Extended;
  115.     FDecimal: Byte;
  116.     FChanging: Boolean;
  117.     FEditorEnabled: Boolean;
  118.     FValueType: TValueType;
  119.     FButton: TRxSpinButton;
  120.     FBtnWindow: TWinControl;
  121.     FArrowKeys: Boolean;
  122.     FOnTopClick: TNotifyEvent;
  123.     FOnBottomClick: TNotifyEvent;
  124. {$IFDEF WIN32}
  125.     FButtonKind: TSpinButtonKind;
  126.     FUpDown: TCustomUpDown;
  127.     function GetButtonKind: TSpinButtonKind;
  128.     procedure SetButtonKind(Value: TSpinButtonKind);
  129.     procedure UpDownClick(Sender: TObject; Button: TUDBtnType);
  130. {$ENDIF}
  131.     function GetMinHeight: Integer;
  132.     procedure GetTextHeight(var SysHeight, Height: Integer);
  133.     function GetValue: Extended;
  134.     function CheckValue(NewValue: Extended): Extended;
  135.     function GetAsInteger: Longint;
  136.     function IsIncrementStored: Boolean;
  137.     function IsMaxStored: Boolean;
  138.     function IsMinStored: Boolean;
  139.     function IsValueStored: Boolean;
  140.     procedure SetArrowKeys(Value: Boolean);
  141.     procedure SetAsInteger(NewValue: Longint);
  142.     procedure SetValue(NewValue: Extended);
  143.     procedure SetValueType(NewType: TValueType);
  144.     procedure SetDecimal(NewValue: Byte);
  145.     function GetButtonWidth: Integer;
  146.     procedure RecreateButton;
  147.     procedure ResizeButton;
  148.     procedure SetEditRect;
  149.     procedure SetAlignment(Value: TAlignment);
  150.     procedure WMSize(var Message: TWMSize); message WM_SIZE;
  151.     procedure CMEnter(var Message: TMessage); message CM_ENTER;
  152.     procedure CMExit(var Message: TCMExit); message CM_EXIT;
  153.     procedure WMPaste(var Message: TWMPaste); message WM_PASTE;
  154.     procedure WMCut(var Message: TWMCut); message WM_CUT;
  155.     procedure CMCtl3DChanged(var Message: TMessage); message CM_CTL3DCHANGED;
  156.     procedure CMEnabledChanged(var Message: TMessage); message CM_ENABLEDCHANGED;
  157.     procedure CMFontChanged(var Message: TMessage); message CM_FONTCHANGED;
  158. {$IFDEF RX_D4}
  159.     procedure CMBiDiModeChanged(var Message: TMessage); message CM_BIDIMODECHANGED;
  160. {$ENDIF}
  161.   protected
  162.     procedure Change; override;
  163.     function IsValidChar(Key: Char): Boolean; virtual;
  164.     procedure UpClick(Sender: TObject); virtual;
  165.     procedure DownClick(Sender: TObject); virtual;
  166.     procedure KeyDown(var Key: Word; Shift: TShiftState); override;
  167.     procedure KeyPress(var Key: Char); override;
  168.     procedure CreateParams(var Params: TCreateParams); override;
  169.     procedure CreateWnd; override;
  170.   public
  171.     constructor Create(AOwner: TComponent); override;
  172.     destructor Destroy; override;
  173.     property AsInteger: Longint read GetAsInteger write SetAsInteger default 0;
  174.     property Text;
  175.   published
  176.     property Alignment: TAlignment read FAlignment write SetAlignment
  177.       default taLeftJustify;
  178.     property ArrowKeys: Boolean read FArrowKeys write SetArrowKeys default True;
  179. {$IFDEF WIN32}
  180.     property ButtonKind: TSpinButtonKind read FButtonKind write SetButtonKind
  181.       default bkDiagonal;
  182. {$ENDIF}
  183.     property Decimal: Byte read FDecimal write SetDecimal default 2;
  184.     property EditorEnabled: Boolean read FEditorEnabled write FEditorEnabled default True;
  185.     property Increment: Extended read FIncrement write FIncrement stored IsIncrementStored;
  186.     property MaxValue: Extended read FMaxValue write FMaxValue stored IsMaxStored;
  187.     property MinValue: Extended read FMinValue write FMinValue stored IsMinStored;
  188.     property ValueType: TValueType read FValueType write SetValueType
  189.       default {$IFDEF CBUILDER} vtInt {$ELSE} vtInteger {$ENDIF};
  190.     property Value: Extended read GetValue write SetValue stored IsValueStored;
  191.     property AutoSelect;
  192.     property AutoSize;
  193.     property BorderStyle;
  194.     property Color;
  195.     property Ctl3D;
  196.     property DragCursor;
  197.     property DragMode;
  198.     property Enabled;
  199.     property Font;
  200. {$IFDEF RX_D4}
  201.     property Anchors;
  202.     property BiDiMode;
  203.     property Constraints;
  204.     property DragKind;
  205.     property ParentBiDiMode;
  206. {$ENDIF}
  207. {$IFDEF WIN32}
  208.   {$IFNDEF VER90}
  209.     property ImeMode;
  210.     property ImeName;
  211.   {$ENDIF}
  212. {$ENDIF}
  213.     property MaxLength;
  214.     property ParentColor;
  215.     property ParentCtl3D;
  216.     property ParentFont;
  217.     property ParentShowHint;
  218.     property PopupMenu;
  219.     property ReadOnly;
  220.     property ShowHint;
  221.     property TabOrder;
  222.     property TabStop;
  223.     property Visible;
  224.     property OnBottomClick: TNotifyEvent read FOnBottomClick write FOnBottomClick;
  225.     property OnTopClick: TNotifyEvent read FOnTopClick write FOnTopClick;
  226.     property OnChange;
  227.     property OnClick;
  228.     property OnDblClick;
  229.     property OnDragDrop;
  230.     property OnDragOver;
  231.     property OnEndDrag;
  232.     property OnEnter;
  233.     property OnExit;
  234.     property OnKeyDown;
  235.     property OnKeyPress;
  236.     property OnKeyUp;
  237.     property OnMouseDown;
  238.     property OnMouseMove;
  239.     property OnMouseUp;
  240. {$IFDEF WIN32}
  241.     property OnStartDrag;
  242. {$ENDIF}
  243. {$IFDEF RX_D5}
  244.     property OnContextPopup;
  245. {$ENDIF}
  246. {$IFDEF RX_D4}
  247.     property OnMouseWheelDown;
  248.     property OnMouseWheelUp;
  249.     property OnEndDock;
  250.     property OnStartDock;
  251. {$ENDIF}
  252.   end;
  253.  
  254. implementation
  255.  
  256. uses {$IFDEF WIN32} CommCtrl, {$ENDIF} VCLUtils;
  257.  
  258. {$IFDEF WIN32}
  259.  {$R *.R32}
  260. {$ELSE}
  261.  {$R *.R16}
  262. {$ENDIF}
  263.  
  264. const
  265.   sSpinUpBtn = 'RXSPINUP';
  266.   sSpinDownBtn = 'RXSPINDOWN';
  267.  
  268. const
  269.   InitRepeatPause = 400; { pause before repeat timer (ms) }
  270.   RepeatPause     = 100;
  271.  
  272. { TRxSpinButton }
  273.  
  274. constructor TRxSpinButton.Create(AOwner: TComponent);
  275. begin
  276.   inherited Create(AOwner);
  277.   FUpBitmap := TBitmap.Create;
  278.   FDownBitmap := TBitmap.Create;
  279.   FUpBitmap.Handle := LoadBitmap(HInstance, sSpinUpBtn);
  280.   FDownBitmap.Handle := LoadBitmap(HInstance, sSpinDownBtn);
  281.   FUpBitmap.OnChange := GlyphChanged;
  282.   FDownBitmap.OnChange := GlyphChanged;
  283.   Height := 20;
  284.   Width := 20;
  285.   FTopDownBtn := TBitmap.Create;
  286.   FBottomDownBtn := TBitmap.Create;
  287.   FNotDownBtn := TBitmap.Create;
  288.   DrawAllBitmap;
  289.   FLastDown := sbNotDown;
  290. end;
  291.  
  292. destructor TRxSpinButton.Destroy;
  293. begin
  294.   FTopDownBtn.Free;
  295.   FBottomDownBtn.Free;
  296.   FNotDownBtn.Free;
  297.   FUpBitmap.Free;
  298.   FDownBitmap.Free;
  299.   FRepeatTimer.Free;
  300.   inherited Destroy;
  301. end;
  302.  
  303. procedure TRxSpinButton.GlyphChanged(Sender: TObject);
  304. begin
  305.   FInvalidate := True;
  306.   Invalidate;
  307. end;
  308.  
  309. function TRxSpinButton.GetUpGlyph: TBitmap;
  310. begin
  311.   Result := FUpBitmap;
  312. end;
  313.  
  314. procedure TRxSpinButton.SetUpGlyph(Value: TBitmap);
  315. begin
  316.   if Value <> nil then FUpBitmap.Assign(Value)
  317.   else FUpBitmap.Handle := LoadBitmap(HInstance, sSpinUpBtn);
  318. end;
  319.  
  320. function TRxSpinButton.GetDownGlyph: TBitmap;
  321. begin
  322.   Result := FDownBitmap;
  323. end;
  324.  
  325. procedure TRxSpinButton.SetDownGlyph(Value: TBitmap);
  326. begin
  327.   if Value <> nil then FDownBitmap.Assign(Value)
  328.   else FDownBitmap.Handle := LoadBitmap(HInstance, sSpinDownBtn);
  329. end;
  330.  
  331. procedure TRxSpinButton.SetDown(Value: TSpinButtonState);
  332. var
  333.   OldState: TSpinButtonState;
  334. begin
  335.   OldState := FDown;
  336.   FDown := Value;
  337.   if OldState <> FDown then Repaint;
  338. end;
  339.  
  340. procedure TRxSpinButton.SetFocusControl(Value: TWinControl);
  341. begin
  342.   FFocusControl := Value;
  343. {$IFDEF WIN32}
  344.   if Value <> nil then Value.FreeNotification(Self);
  345. {$ENDIF}
  346. end;
  347.  
  348. procedure TRxSpinButton.Notification(AComponent: TComponent;
  349.   Operation: TOperation);
  350. begin
  351.   inherited Notification(AComponent, Operation);
  352.   if (Operation = opRemove) and (AComponent = FFocusControl) then
  353.     FFocusControl := nil;
  354. end;
  355.  
  356. procedure TRxSpinButton.Paint;
  357. begin
  358.   if not Enabled and not (csDesigning in ComponentState) then
  359.     FDragging := False;
  360.   if (FNotDownBtn.Height <> Height) or (FNotDownBtn.Width <> Width) or
  361.     FInvalidate then DrawAllBitmap;
  362.   FInvalidate := False;
  363.   with Canvas do
  364.     case FDown of
  365.       sbNotDown: Draw(0, 0, FNotDownBtn);
  366.       sbTopDown: Draw(0, 0, FTopDownBtn);
  367.       sbBottomDown: Draw(0, 0, FBottomDownBtn);
  368.     end;
  369. end;
  370.  
  371. procedure TRxSpinButton.DrawAllBitmap;
  372. begin
  373.   DrawBitmap(FTopDownBtn, sbTopDown);
  374.   DrawBitmap(FBottomDownBtn, sbBottomDown);
  375.   DrawBitmap(FNotDownBtn, sbNotDown);
  376. end;
  377.  
  378. procedure TRxSpinButton.DrawBitmap(ABitmap: TBitmap; ADownState: TSpinButtonState);
  379. var
  380.   R, RSrc: TRect;
  381.   dRect: Integer;
  382.   {Temp: TBitmap;}
  383. begin
  384.   ABitmap.Height := Height;
  385.   ABitmap.Width := Width;
  386.   with ABitmap.Canvas do begin
  387.     R := Bounds(0, 0, Width, Height);
  388.     Pen.Width := 1;
  389.     Brush.Color := clBtnFace;
  390.     Brush.Style := bsSolid;
  391.     FillRect(R);
  392.     { buttons frame }
  393.     Pen.Color := clWindowFrame;
  394.     Rectangle(0, 0, Width, Height);
  395.     MoveTo(-1, Height);
  396.     LineTo(Width, -1);
  397.     { top button }
  398.     if ADownState = sbTopDown then Pen.Color := clBtnShadow
  399.     else Pen.Color := clBtnHighlight;
  400.     MoveTo(1, Height - 4);
  401.     LineTo(1, 1);
  402.     LineTo(Width - 3, 1);
  403.     if ADownState = sbTopDown then Pen.Color := clBtnHighlight
  404.       else Pen.Color := clBtnShadow;
  405.     if ADownState <> sbTopDown then begin
  406.       MoveTo(1, Height - 3);
  407.       LineTo(Width - 2, 0);
  408.     end;
  409.     { bottom button }
  410.     if ADownState = sbBottomDown then Pen.Color := clBtnHighlight
  411.       else Pen.Color := clBtnShadow;
  412.     MoveTo(2, Height - 2);
  413.     LineTo(Width - 2, Height - 2);
  414.     LineTo(Width - 2, 1);
  415.     if ADownState = sbBottomDown then Pen.Color := clBtnShadow
  416.       else Pen.Color := clBtnHighlight;
  417.     MoveTo(2, Height - 2);
  418.     LineTo(Width - 1, 1);
  419.     { top glyph }
  420.     dRect := 1;
  421.     if ADownState = sbTopDown then Inc(dRect);
  422.     R := Bounds(Round((Width / 4) - (FUpBitmap.Width / 2)) + dRect,
  423.       Round((Height / 4) - (FUpBitmap.Height / 2)) + dRect, FUpBitmap.Width,
  424.       FUpBitmap.Height);
  425.     RSrc := Bounds(0, 0, FUpBitmap.Width, FUpBitmap.Height);
  426.     {
  427.     if Self.Enabled or (csDesigning in ComponentState) then
  428.       BrushCopy(R, FUpBitmap, RSrc, FUpBitmap.TransparentColor)
  429.     else begin
  430.       Temp := CreateDisabledBitmap(FUpBitmap, clBlack);
  431.       try
  432.         BrushCopy(R, Temp, RSrc, Temp.TransparentColor);
  433.       finally
  434.         Temp.Free;
  435.       end;
  436.     end;
  437.     }
  438.     BrushCopy(R, FUpBitmap, RSrc, FUpBitmap.TransparentColor);
  439.     { bottom glyph }
  440.     R := Bounds(Round((3 * Width / 4) - (FDownBitmap.Width / 2)) - 1,
  441.       Round((3 * Height / 4) - (FDownBitmap.Height / 2)) - 1,
  442.       FDownBitmap.Width, FDownBitmap.Height);
  443.     RSrc := Bounds(0, 0, FDownBitmap.Width, FDownBitmap.Height);
  444.     {
  445.     if Self.Enabled or (csDesigning in ComponentState) then
  446.       BrushCopy(R, FDownBitmap, RSrc, FDownBitmap.TransparentColor)
  447.     else begin
  448.       Temp := CreateDisabledBitmap(FDownBitmap, clBlack);
  449.       try
  450.         BrushCopy(R, Temp, RSrc, Temp.TransparentColor);
  451.       finally
  452.         Temp.Free;
  453.       end;
  454.     end;
  455.     }
  456.     BrushCopy(R, FDownBitmap, RSrc, FDownBitmap.TransparentColor);
  457.     if ADownState = sbBottomDown then begin
  458.       Pen.Color := clBtnShadow;
  459.       MoveTo(3, Height - 2);
  460.       LineTo(Width - 1, 2);
  461.     end;
  462.   end;
  463. end;
  464.  
  465. procedure TRxSpinButton.CMEnabledChanged(var Message: TMessage);
  466. begin
  467.   inherited;
  468.   FInvalidate := True;
  469.   Invalidate;
  470. end;
  471.  
  472. procedure TRxSpinButton.TopClick;
  473. begin
  474.   if Assigned(FOnTopClick) then begin
  475.     FOnTopClick(Self);
  476.     if not (csLButtonDown in ControlState) then FDown := sbNotDown;
  477.   end;
  478. end;
  479.  
  480. procedure TRxSpinButton.BottomClick;
  481. begin
  482.   if Assigned(FOnBottomClick) then begin
  483.     FOnBottomClick(Self);
  484.     if not (csLButtonDown in ControlState) then FDown := sbNotDown;
  485.   end;
  486. end;
  487.  
  488. procedure TRxSpinButton.MouseDown(Button: TMouseButton; Shift: TShiftState;
  489.   X, Y: Integer);
  490. begin
  491.   inherited MouseDown(Button, Shift, X, Y);
  492.   if (Button = mbLeft) and Enabled then begin
  493.     if (FFocusControl <> nil) and FFocusControl.TabStop and
  494.       FFocusControl.CanFocus and (GetFocus <> FFocusControl.Handle) then
  495.         FFocusControl.SetFocus;
  496.     if FDown = sbNotDown then begin
  497.       FLastDown := FDown;
  498.       if Y > (-(Height/Width) * X + Height) then begin
  499.         FDown := sbBottomDown;
  500.         BottomClick;
  501.       end
  502.       else begin
  503.         FDown := sbTopDown;
  504.         TopClick;
  505.       end;
  506.       if FLastDown <> FDown then begin
  507.         FLastDown := FDown;
  508.         Repaint;
  509.       end;
  510.       if FRepeatTimer = nil then FRepeatTimer := TTimer.Create(Self);
  511.       FRepeatTimer.OnTimer := TimerExpired;
  512.       FRepeatTimer.Interval := InitRepeatPause;
  513.       FRepeatTimer.Enabled := True;
  514.     end;
  515.     FDragging := True;
  516.   end;
  517. end;
  518.  
  519. procedure TRxSpinButton.MouseMove(Shift: TShiftState; X, Y: Integer);
  520. var
  521.   NewState: TSpinButtonState;
  522. begin
  523.   inherited MouseMove(Shift, X, Y);
  524.   if FDragging then begin
  525.     if (X >= 0) and (X <= Width) and (Y >= 0) and (Y <= Height) then begin
  526.       NewState := FDown;
  527.       if Y > (-(Width / Height) * X + Height) then begin
  528.         if (FDown <> sbBottomDown) then begin
  529.           if FLastDown = sbBottomDown then FDown := sbBottomDown
  530.           else FDown := sbNotDown;
  531.           if NewState <> FDown then Repaint;
  532.         end;
  533.       end
  534.       else begin
  535.         if (FDown <> sbTopDown) then begin
  536.           if (FLastDown = sbTopDown) then FDown := sbTopDown
  537.           else FDown := sbNotDown;
  538.           if NewState <> FDown then Repaint;
  539.         end;
  540.       end;
  541.     end else
  542.       if FDown <> sbNotDown then begin
  543.         FDown := sbNotDown;
  544.         Repaint;
  545.       end;
  546.   end;
  547. end;
  548.  
  549. procedure TRxSpinButton.MouseUp(Button: TMouseButton; Shift: TShiftState;
  550.   X, Y: Integer);
  551. begin
  552.   inherited MouseUp(Button, Shift, X, Y);
  553.   if FDragging then begin
  554.     FDragging := False;
  555.     if (X >= 0) and (X <= Width) and (Y >= 0) and (Y <= Height) then begin
  556.       FDown := sbNotDown;
  557.       FLastDown := sbNotDown;
  558.       Repaint;
  559.     end;
  560.   end;
  561. end;
  562.  
  563. procedure TRxSpinButton.TimerExpired(Sender: TObject);
  564. begin
  565.   FRepeatTimer.Interval := RepeatPause;
  566.   if (FDown <> sbNotDown) and MouseCapture then begin
  567.     try
  568.       if FDown = sbBottomDown then BottomClick else TopClick;
  569.     except
  570.       FRepeatTimer.Enabled := False;
  571.       raise;
  572.     end;
  573.   end;
  574. end;
  575.  
  576. function DefBtnWidth: Integer;
  577. begin
  578.   Result := GetSystemMetrics(SM_CXVSCROLL);
  579.   if Result > 15 then Result := 15;
  580. end;
  581.  
  582. {$IFDEF WIN32}
  583.  
  584. type
  585.   TRxUpDown = class(TCustomUpDown)
  586.   private
  587.     FChanging: Boolean;
  588.     procedure ScrollMessage(var Message: TWMVScroll);
  589.     procedure WMHScroll(var Message: TWMHScroll); message CN_HSCROLL;
  590.     procedure WMVScroll(var Message: TWMVScroll); message CN_VSCROLL;
  591.     procedure WMSize(var Message: TWMSize); message WM_SIZE;
  592.   public
  593.     constructor Create(AOwner: TComponent); override;
  594.     destructor Destroy; override;
  595.   published
  596.     property OnClick;
  597.   end;
  598.  
  599. constructor TRxUpDown.Create(AOwner: TComponent);
  600. begin
  601.   inherited Create(AOwner);
  602.   Orientation := udVertical;
  603.   Min := -1;
  604.   Max := 1;
  605.   Position := 0;
  606. end;
  607.  
  608. destructor TRxUpDown.Destroy;
  609. begin
  610.   OnClick := nil;
  611.   inherited Destroy;
  612. end;
  613.  
  614. procedure TRxUpDown.ScrollMessage(var Message: TWMVScroll);
  615. begin
  616.   if Message.ScrollCode = SB_THUMBPOSITION then begin
  617.     if not FChanging then begin
  618.       FChanging := True;
  619.       try
  620.         if Message.Pos > 0 then Click(btNext)
  621.         else if Message.Pos < 0 then Click(btPrev);
  622.         if HandleAllocated then
  623.           SendMessage(Handle, UDM_SETPOS, 0, 0);
  624.       finally
  625.         FChanging := False;
  626.       end;
  627.     end;
  628.   end;
  629. end;
  630.  
  631. procedure TRxUpDown.WMHScroll(var Message: TWMHScroll);
  632. begin
  633.   ScrollMessage(TWMVScroll(Message));
  634. end;
  635.  
  636. procedure TRxUpDown.WMVScroll(var Message: TWMVScroll);
  637. begin
  638.   ScrollMessage(Message);
  639. end;
  640.  
  641. procedure TRxUpDown.WMSize(var Message: TWMSize);
  642. begin
  643.   inherited;
  644.   if Width <> DefBtnWidth then Width := DefBtnWidth;
  645. end;
  646. {$ENDIF WIN32}
  647.  
  648. { TRxSpinEdit }
  649.  
  650. constructor TRxSpinEdit.Create(AOwner: TComponent);
  651. begin
  652.   inherited Create(AOwner);
  653.   Text := '0';
  654.   ControlStyle := ControlStyle - [csSetCaption];
  655.   FIncrement := 1.0;
  656.   FDecimal := 2;
  657.   FEditorEnabled := True;
  658. {$IFDEF WIN32}
  659.   FButtonKind := bkDiagonal;
  660. {$ENDIF}
  661.   FArrowKeys := True;
  662.   RecreateButton;
  663. end;
  664.  
  665. destructor TRxSpinEdit.Destroy;
  666. begin
  667.   Destroying;
  668.   FChanging := True;
  669.   if FButton <> nil then begin
  670.     FButton.Free;
  671.     FButton := nil;
  672.     FBtnWindow.Free;
  673.     FBtnWindow := nil;
  674.   end;
  675. {$IFDEF WIN32}
  676.   if FUpDown <> nil then begin
  677.     FUpDown.Free;
  678.     FUpDown := nil;
  679.   end;
  680. {$ENDIF}
  681.   inherited Destroy;
  682. end;
  683.  
  684. procedure TRxSpinEdit.RecreateButton;
  685. begin
  686.   if (csDestroying in ComponentState) then Exit;
  687.   FButton.Free;
  688.   FButton := nil;
  689.   FBtnWindow.Free;
  690.   FBtnWindow := nil;
  691. {$IFDEF WIN32}
  692.   FUpDown.Free;
  693.   FUpDown := nil;
  694.   if GetButtonKind = bkStandard then begin
  695.     FUpDown := TRxUpDown.Create(Self);
  696.     with TRxUpDown(FUpDown) do begin
  697.       Visible := True;
  698.       SetBounds(0, 0, DefBtnWidth, Self.Height);
  699. {$IFDEF RX_D4}
  700.       if (BiDiMode = bdRightToLeft) then Align := alLeft else
  701. {$ENDIF}
  702.       Align := alRight;
  703.       Parent := Self;
  704.       OnClick := UpDownClick;
  705.     end;
  706.   end
  707.   else begin
  708. {$ENDIF}
  709.     FBtnWindow := TWinControl.Create(Self);
  710.     FBtnWindow.Visible := True;
  711.     FBtnWindow.Parent := Self;
  712.     FBtnWindow.SetBounds(0, 0, Height, Height);
  713.     FButton := TRxSpinButton.Create(Self);
  714.     FButton.Visible := True;
  715.     FButton.Parent := FBtnWindow;
  716.     FButton.FocusControl := Self;
  717.     FButton.OnTopClick := UpClick;
  718.     FButton.OnBottomClick := DownClick;
  719.     FButton.SetBounds(0, 0, FBtnWindow.Width, FBtnWindow.Height);
  720. {$IFDEF WIN32}
  721.   end;
  722. {$ENDIF}
  723. end;
  724.  
  725. procedure TRxSpinEdit.SetArrowKeys(Value: Boolean);
  726. begin
  727.   FArrowKeys := Value;
  728. {$IFDEF WIN32}
  729.   ResizeButton;
  730. {$ENDIF}
  731. end;
  732.  
  733. {$IFDEF WIN32}
  734. function TRxSpinEdit.GetButtonKind: TSpinButtonKind;
  735. begin
  736.   if NewStyleControls then Result := FButtonKind
  737.   else Result := bkDiagonal;
  738. end;
  739.  
  740. procedure TRxSpinEdit.SetButtonKind(Value: TSpinButtonKind);
  741. var
  742.   OldKind: TSpinButtonKind;
  743. begin
  744.   OldKind := FButtonKind;
  745.   FButtonKind := Value;
  746.   if OldKind <> GetButtonKind then begin
  747.     RecreateButton;
  748.     ResizeButton;
  749.     SetEditRect;
  750.   end;
  751. end;
  752.  
  753. procedure TRxSpinEdit.UpDownClick(Sender: TObject; Button: TUDBtnType);
  754. begin
  755.   if TabStop and CanFocus then SetFocus;
  756.   case Button of
  757.     btNext: UpClick(Sender);
  758.     btPrev: DownClick(Sender);
  759.   end;
  760. end;
  761. {$ENDIF WIN32}
  762.  
  763. function TRxSpinEdit.GetButtonWidth: Integer;
  764. begin
  765. {$IFDEF WIN32}
  766.   if FUpDown <> nil then Result := FUpDown.Width else
  767. {$ENDIF}
  768.   if FButton <> nil then Result := FButton.Width
  769.   else Result := DefBtnWidth;
  770. end;
  771.  
  772. procedure TRxSpinEdit.ResizeButton;
  773. {$IFDEF WIN32}
  774. var
  775.   R: TRect;
  776. {$ENDIF}
  777. begin
  778. {$IFDEF WIN32}
  779.   if FUpDown <> nil then begin
  780.     FUpDown.Width := DefBtnWidth;
  781.  {$IFDEF RX_D4}
  782.     if (BiDiMode = bdRightToLeft) then FUpDown.Align := alLeft else
  783.  {$ENDIF}
  784.     FUpDown.Align := alRight;
  785.   end
  786.   else if FButton <> nil then begin { bkDiagonal }
  787.     if NewStyleControls and Ctl3D and (BorderStyle = bsSingle) then
  788.       R := Bounds(Width - Height - 1, -1, Height - 3, Height - 3)
  789.     else
  790.       R := Bounds(Width - Height, 0, Height, Height);
  791.  {$IFDEF RX_D4}
  792.     if (BiDiMode = bdRightToLeft) then begin
  793.       if NewStyleControls and Ctl3D and (BorderStyle = bsSingle) then begin
  794.         R.Left := -1;
  795.         R.Right := Height - 4;
  796.       end
  797.       else begin
  798.         R.Left := 0;
  799.         R.Right := Height;
  800.       end;
  801.     end;
  802.  {$ENDIF}
  803.     with R do
  804.       FBtnWindow.SetBounds(Left, Top, Right - Left, Bottom - Top);
  805.     FButton.SetBounds(0, 0, FBtnWindow.Width, FBtnWindow.Height);
  806.   end;
  807. {$ELSE}
  808.   if FButton <> nil then begin
  809.     FBtnWindow.SetBounds(Width - Height, 0, Height, Height);
  810.     FButton.SetBounds(0, 0, FBtnWindow.Width, FBtnWindow.Height);
  811.   end;
  812. {$ENDIF}
  813. end;
  814.  
  815. procedure TRxSpinEdit.KeyDown(var Key: Word; Shift: TShiftState);
  816. begin
  817.   inherited KeyDown(Key, Shift);
  818.   if ArrowKeys and (Key in [VK_UP, VK_DOWN]) then begin
  819.     if Key = VK_UP then UpClick(Self)
  820.     else if Key = VK_DOWN then DownClick(Self);
  821.     Key := 0;
  822.   end;
  823. end;
  824.  
  825. procedure TRxSpinEdit.Change;
  826. begin
  827.   if not FChanging then inherited Change;
  828. end;
  829.  
  830. procedure TRxSpinEdit.KeyPress(var Key: Char);
  831. begin
  832.   if not IsValidChar(Key) then begin
  833.     Key := #0;
  834.     MessageBeep(0)
  835.   end;
  836.   if Key <> #0 then begin
  837.     inherited KeyPress(Key);
  838.     if (Key = Char(VK_RETURN)) or (Key = Char(VK_ESCAPE)) then begin
  839.       { must catch and remove this, since is actually multi-line }
  840.       GetParentForm(Self).Perform(CM_DIALOGKEY, Byte(Key), 0);
  841.       if Key = Char(VK_RETURN) then Key := #0;
  842.     end;
  843.   end;
  844. end;
  845.  
  846. function TRxSpinEdit.IsValidChar(Key: Char): Boolean;
  847. var
  848.   ValidChars: set of Char;
  849. begin
  850.   ValidChars := ['+', '-', '0'..'9'];
  851.   if ValueType = vtFloat then begin
  852.     if Pos(DecimalSeparator, Text) = 0 then
  853.       ValidChars := ValidChars + [DecimalSeparator];
  854.     if Pos('E', AnsiUpperCase(Text)) = 0 then
  855.       ValidChars := ValidChars + ['e', 'E'];
  856.   end
  857.   else if ValueType = vtHex then begin
  858.     ValidChars := ValidChars + ['A'..'F', 'a'..'f'];
  859.   end;
  860.   Result := (Key in ValidChars) or (Key < #32);
  861.   if not FEditorEnabled and Result and ((Key >= #32) or
  862.     (Key = Char(VK_BACK)) or (Key = Char(VK_DELETE))) then Result := False;
  863. end;
  864.  
  865. procedure TRxSpinEdit.CreateParams(var Params: TCreateParams);
  866. const
  867. {$IFDEF RX_D4}
  868.   Alignments: array[Boolean, TAlignment] of DWORD =
  869.     ((ES_LEFT, ES_RIGHT, ES_CENTER), (ES_RIGHT, ES_LEFT, ES_CENTER));
  870. {$ELSE}
  871.   Alignments: array[TAlignment] of Longint = (ES_LEFT, ES_RIGHT, ES_CENTER);
  872. {$ENDIF}
  873. begin
  874.   inherited CreateParams(Params);
  875.   Params.Style := Params.Style or ES_MULTILINE or WS_CLIPCHILDREN or
  876. {$IFDEF RX_D4}
  877.     Alignments[UseRightToLeftAlignment, FAlignment];
  878. {$ELSE}
  879.     Alignments[FAlignment];
  880. {$ENDIF}
  881. end;
  882.  
  883. procedure TRxSpinEdit.CreateWnd;
  884. begin
  885.   inherited CreateWnd;
  886.   SetEditRect;
  887. end;
  888.  
  889. procedure TRxSpinEdit.SetEditRect;
  890. var
  891.   Loc: TRect;
  892. begin
  893. {$IFDEF RX_D4}
  894.   if (BiDiMode = bdRightToLeft) then
  895.     SetRect(Loc, GetButtonWidth + 1, 0, ClientWidth - 1,
  896.       ClientHeight + 1) else
  897. {$ENDIF RX_D4}
  898.   SetRect(Loc, 0, 0, ClientWidth - GetButtonWidth - 2, ClientHeight + 1);
  899.   SendMessage(Handle, EM_SETRECTNP, 0, Longint(@Loc));
  900. end;
  901.  
  902. procedure TRxSpinEdit.SetAlignment(Value: TAlignment);
  903. begin
  904.   if FAlignment <> Value then begin
  905.     FAlignment := Value;
  906.     RecreateWnd;
  907.   end;
  908. end;
  909.  
  910. procedure TRxSpinEdit.WMSize(var Message: TWMSize);
  911. var
  912.   MinHeight: Integer;
  913. begin
  914.   inherited;
  915.   MinHeight := GetMinHeight;
  916.   { text edit bug: if size to less than minheight, then edit ctrl does
  917.     not display the text }
  918.   if Height < MinHeight then
  919.     Height := MinHeight
  920.   else begin
  921.     ResizeButton;
  922.     SetEditRect;
  923.   end;
  924. end;
  925.  
  926. procedure TRxSpinEdit.GetTextHeight(var SysHeight, Height: Integer);
  927. var
  928.   DC: HDC;
  929.   SaveFont: HFont;
  930.   SysMetrics, Metrics: TTextMetric;
  931. begin
  932.   DC := GetDC(0);
  933.   GetTextMetrics(DC, SysMetrics);
  934.   SaveFont := SelectObject(DC, Font.Handle);
  935.   GetTextMetrics(DC, Metrics);
  936.   SelectObject(DC, SaveFont);
  937.   ReleaseDC(0, DC);
  938.   SysHeight := SysMetrics.tmHeight;
  939.   Height := Metrics.tmHeight;
  940. end;
  941.  
  942. function TRxSpinEdit.GetMinHeight: Integer;
  943. var
  944.   I, H: Integer;
  945. begin
  946.   GetTextHeight(I, H);
  947.   if I > H then I := H;
  948.   Result := H + {$IFNDEF WIN32} (I div 4) + {$ENDIF}
  949.     (GetSystemMetrics(SM_CYBORDER) * 4) + 1;
  950. end;
  951.  
  952. procedure TRxSpinEdit.UpClick(Sender: TObject);
  953. var
  954.   OldText: string;
  955. begin
  956.   if ReadOnly then MessageBeep(0)
  957.   else begin
  958.     FChanging := True;
  959.     try
  960.       OldText := inherited Text;
  961.       Value := Value + FIncrement;
  962.     finally
  963.       FChanging := False;
  964.     end;
  965.     if CompareText(inherited Text, OldText) <> 0 then begin
  966.       Modified := True;
  967.       Change;
  968.     end;
  969.     if Assigned(FOnTopClick) then FOnTopClick(Self);
  970.   end;
  971. end;
  972.  
  973. procedure TRxSpinEdit.DownClick(Sender: TObject);
  974. var
  975.   OldText: string;
  976. begin
  977.   if ReadOnly then MessageBeep(0)
  978.   else begin
  979.     FChanging := True;
  980.     try
  981.       OldText := inherited Text;
  982.       Value := Value - FIncrement;
  983.     finally
  984.       FChanging := False;
  985.     end;
  986.     if CompareText(inherited Text, OldText) <> 0 then begin
  987.       Modified := True;
  988.       Change;
  989.     end;
  990.     if Assigned(FOnBottomClick) then FOnBottomClick(Self);
  991.   end;
  992. end;
  993.  
  994. {$IFDEF RX_D4}
  995. procedure TRxSpinEdit.CMBiDiModeChanged(var Message: TMessage);
  996. begin
  997.   inherited;
  998.   ResizeButton;
  999.   SetEditRect;
  1000. end;
  1001. {$ENDIF}
  1002.  
  1003. procedure TRxSpinEdit.CMFontChanged(var Message: TMessage);
  1004. begin
  1005.   inherited;
  1006.   ResizeButton;
  1007.   SetEditRect;
  1008. end;
  1009.  
  1010. procedure TRxSpinEdit.CMCtl3DChanged(var Message: TMessage);
  1011. begin
  1012.   inherited;
  1013.   ResizeButton;
  1014.   SetEditRect;
  1015. end;
  1016.  
  1017. procedure TRxSpinEdit.CMEnabledChanged(var Message: TMessage);
  1018. begin
  1019.   inherited;
  1020. {$IFDEF WIN32}
  1021.   if FUpDown <> nil then begin
  1022.     FUpDown.Enabled := Enabled;
  1023.     ResizeButton;
  1024.   end;
  1025. {$ENDIF}
  1026.   if FButton <> nil then FButton.Enabled := Enabled;
  1027. end;
  1028.  
  1029. procedure TRxSpinEdit.WMPaste(var Message: TWMPaste);
  1030. begin
  1031.   if not FEditorEnabled or ReadOnly then Exit;
  1032.   inherited;
  1033. end;
  1034.  
  1035. procedure TRxSpinEdit.WMCut(var Message: TWMCut);
  1036. begin
  1037.   if not FEditorEnabled or ReadOnly then Exit;
  1038.   inherited;
  1039. end;
  1040.  
  1041. procedure TRxSpinEdit.CMExit(var Message: TCMExit);
  1042. begin
  1043.   inherited;
  1044.   if CheckValue(Value) <> Value then SetValue(Value);
  1045. end;
  1046.  
  1047. procedure TRxSpinEdit.CMEnter(var Message: TMessage);
  1048. begin
  1049.   if AutoSelect and not (csLButtonDown in ControlState) then SelectAll;
  1050.   inherited;
  1051. end;
  1052.  
  1053. function TRxSpinEdit.GetValue: Extended;
  1054. begin
  1055.   try
  1056.     if ValueType = vtFloat then Result := StrToFloat(Text)
  1057.     else if ValueType = vtHex then Result := StrToInt('$' + Text)
  1058.     else Result := StrToInt(Text);
  1059.   except
  1060.     if ValueType = vtFloat then Result := FMinValue
  1061.     else Result := Trunc(FMinValue);
  1062.   end;
  1063. end;
  1064.  
  1065. procedure TRxSpinEdit.SetValue(NewValue: Extended);
  1066. begin
  1067.   if ValueType = vtFloat then
  1068.     Text := FloatToStrF(CheckValue(NewValue), ffFixed, 15, FDecimal)
  1069.   else if ValueType = vtHex then
  1070.     Text := IntToHex(Round(CheckValue(NewValue)), 1)
  1071.   else
  1072.     Text := IntToStr(Round(CheckValue(NewValue)));
  1073. end;
  1074.  
  1075. function TRxSpinEdit.GetAsInteger: Longint;
  1076. begin
  1077.   Result := Trunc(GetValue);
  1078. end;
  1079.  
  1080. procedure TRxSpinEdit.SetAsInteger(NewValue: Longint);
  1081. begin
  1082.   SetValue(NewValue);
  1083. end;
  1084.  
  1085. procedure TRxSpinEdit.SetValueType(NewType: TValueType);
  1086. begin
  1087.   if FValueType <> NewType then begin
  1088.     FValueType := NewType;
  1089.     Value := GetValue;
  1090.     if FValueType in [{$IFDEF CBUILDER} vtInt {$ELSE} vtInteger {$ENDIF}, vtHex] then
  1091.     begin
  1092.       FIncrement := Round(FIncrement);
  1093.       if FIncrement = 0 then FIncrement := 1;
  1094.     end;
  1095.   end;
  1096. end;
  1097.  
  1098. function TRxSpinEdit.IsIncrementStored: Boolean;
  1099. begin
  1100.   Result := FIncrement <> 1.0;
  1101. end;
  1102.  
  1103. function TRxSpinEdit.IsMaxStored: Boolean;
  1104. begin
  1105.   Result := (MaxValue <> 0.0);
  1106. end;
  1107.  
  1108. function TRxSpinEdit.IsMinStored: Boolean;
  1109. begin
  1110.   Result := (MinValue <> 0.0);
  1111. end;
  1112.  
  1113. function TRxSpinEdit.IsValueStored: Boolean;
  1114. begin
  1115.   Result := (GetValue <> 0.0);
  1116. end;
  1117.  
  1118. procedure TRxSpinEdit.SetDecimal(NewValue: Byte);
  1119. begin
  1120.   if FDecimal <> NewValue then begin
  1121.     FDecimal := NewValue;
  1122.     Value := GetValue;
  1123.   end;
  1124. end;
  1125.  
  1126. function TRxSpinEdit.CheckValue(NewValue: Extended): Extended;
  1127. begin
  1128.   Result := NewValue;
  1129.   if (FMaxValue <> FMinValue) then begin
  1130.     if NewValue < FMinValue then
  1131.       Result := FMinValue
  1132.     else if NewValue > FMaxValue then
  1133.       Result := FMaxValue;
  1134.   end;
  1135. end;
  1136.  
  1137. end.